#  File src/library/tools/R/utils.R
#  Part of the R package, http://www.R-project.org
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  A copy of the GNU General Public License is available at
#  http://www.r-project.org/Licenses/

### * File utilities.

### ** file_path_as_absolute

file_path_as_absolute <-
function(x)
{
    ## Turn a possibly relative file path absolute, performing tilde
    ## expansion if necessary.
    ## Seems the only way we can do this is 'temporarily' change the
    ## working dir and see where this takes us.
    if(!file.exists(epath <- path.expand(x)))
        stop(gettextf("file '%s' does not exist", x),
             domain = NA)
    cwd <- getwd()
    on.exit(setwd(cwd))
    if(file_test("-d", epath)) {
        ## Combining dirname and basename does not work for e.g. '.' or
        ## '..' on Unix ...
        setwd(epath)
        getwd()
    }
    else {
        setwd(dirname(epath))
        ## getwd() can be "/" or "d:/"
        file.path(sub("/$", "", getwd()), basename(epath))
    }
}

### ** file_path_sans_ext

file_path_sans_ext <-
function(x)
{
    ## Return the file paths without extensions.
    ## (Only purely alphanumeric extensions are recognized.)
    sub("([^.]+)\\.[[:alnum:]]+$", "\\1", x)
}

### ** file_test

file_test <-
function(op, x, y)
{
    ## Provide shell-style '-f', '-d', '-x', '-nt' and '-ot' tests.
    ## Note that file.exists() only tests existence ('test -e' on some
    ## systems), and that our '-f' tests for existence and not being a
    ## directory (the GNU variant tests for being a regular file).
    ## Note: vectorized in x and y.
    switch(op,
           "-f" = !is.na(isdir <- file.info(x)$isdir) & !isdir,
           "-d" = !is.na(isdir <- file.info(x)$isdir) & isdir,
           "-nt" = (!is.na(mt.x <- file.info(x)$mtime)
                    & !is.na(mt.y <- file.info(y)$mtime)
                    & (mt.x > mt.y)),
           "-ot" = (!is.na(mt.x <- file.info(x)$mtime)
                    & !is.na(mt.y <- file.info(y)$mtime)
                    & (mt.x < mt.y)),
           "-x" = (file.access(x, 1L) == 0L),
           stop(gettextf("test '%s' is not available", op),
                domain = NA))
}

### ** list_files_with_exts

list_files_with_exts <-
function(dir, exts, all.files = FALSE, full.names = TRUE)
{
    ## Return the paths or names of the files in @code{dir} with
    ## extension in @code{exts}.
    ## Might be in a zipped dir on Windows.
    if(file.exists(file.path(dir, "filelist")) &&
       any(file.exists(file.path(dir, c("Rdata.zip", "Rex.zip", "Rhelp.zip")))))
    {
        files <- readLines(file.path(dir, "filelist"))
        if(!all.files)
            files <- grep("^[^.]", files, value = TRUE)
    } else {
        files <- list.files(dir, all.files = all.files)
    }
    ## does not cope with exts with '.' in.
    ## files <- files[sub(".*\\.", "", files) %in% exts]
    patt <- paste("\\.(", paste(exts, collapse="|"), ")$", sep = "")
    files <- grep(patt, files, value = TRUE)
    if(full.names)
        files <- if(length(files))
            file.path(dir, files)
        else
            character()
    files
}

### ** list_files_with_type

list_files_with_type <-
function(dir, type, all.files = FALSE, full.names = TRUE,
         OS_subdirs = .OStype())
{
    ## Return a character vector with the paths of the files in
    ## @code{dir} of type @code{type} (as in .make_file_exts()).
    ## When listing R code and documentation files, files in OS-specific
    ## subdirectories are included (if present) according to the value
    ## of @code{OS_subdirs}.

    exts <- .make_file_exts(type)
    files <-
        list_files_with_exts(dir, exts, all.files = all.files,
                             full.names = full.names)

    if(type %in% c("code", "docs")) {
        for(os in OS_subdirs) {
            os_dir <- file.path(dir, os)
            if(file_test("-d", os_dir)) {
                os_files <- list_files_with_exts(os_dir, exts,
                                                 all.files = all.files,
                                                 full.names = FALSE)
                os_files <- file.path(if(full.names) os_dir else os,
                                      os_files)
                files <- c(files, os_files)
            }
        }
    }
    ## avoid ranges since they depend on the collation order in the locale.
    ## in particular, Estonian sorts Z after S.
    if(type %in% c("code", "docs")) { # only certain filenames are valid.
        files <- files[grep("^[ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789]", basename(files))]
    }
    if(type %in% "demo") {           # only certain filenames are valid.
        files <- files[grep("^[ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz]", basename(files))]
    }
    files
}

### ** showNonASCII

showNonASCII <-
function(x)
{
    ## All that is needed here is an 8-bit encoding that includes ASCII.
    ## The only one we guarantee to exist is 'latin1'.
    ## The default sub=NA is faster.
    ind <- is.na(iconv(x, "latin1", "ASCII"))
    if(any(ind))
        cat(paste(which(ind), ": ",
                  iconv(x[ind], "latin1", "ASCII", sub="byte"), sep=""),
            sep="\n")
}

### * Text utilities.

### ** delimMatch

delimMatch <-
function(x, delim = c("{", "}"), syntax = "Rd")
{
    if(!is.character(x))
        stop("argument 'x' must be a character vector")
    ## FIXME: bytes or chars?
    if((length(delim) != 2L) || any(nchar(delim) != 1L))
        stop("argument 'delim' must specify two characters")
    if(syntax != "Rd")
        stop("only Rd syntax is currently supported")

    .Call(delim_match, x, delim)
}


### * LaTeX utilities

### ** texi2dvi

texi2dvi <-
function(file, pdf = FALSE, clean = FALSE, quiet = TRUE,
         texi2dvi = getOption("texi2dvi"), texinputs = NULL)
{
    ## Run texi2dvi on a latex file, or emulate it.

    if(is.null(texi2dvi) || !nzchar(texi2dvi))
        texi2dvi <- Sys.which("texi2dvi")

    envSep <- .Platform$path.sep
    Rtexmf <- file.path(R.home("share"), "texmf")
    ## "" forces use of default paths.
    texinputs <- paste(c(texinputs, Rtexmf, ""), collapse = envSep)
    ## not clear if this is needed, but works
    if(.Platform$OS.type == "windows")
        texinputs <- gsub("\\\\", "/", texinputs)

    otexinputs <- Sys.getenv("TEXINPUTS", unset = NA)
    if(is.na(otexinputs)) {
        on.exit(Sys.unsetenv("TEXINPUTS"))
        otexinputs <- "."
    } else on.exit(Sys.setenv(TEXINPUTS = otexinputs))
    Sys.setenv(TEXINPUTS = paste(otexinputs, texinputs, sep = envSep))
    bibinputs <- Sys.getenv("BIBINPUTS", unset = NA)
    if(is.na(bibinputs)) {
        on.exit(Sys.unsetenv("BIBINPUTS"), add = TRUE)
        bibinputs <- "."
    } else on.exit(Sys.setenv(BIBINPUTS = bibinputs, add = TRUE))
    Sys.setenv(BIBINPUTS = paste(bibinputs, texinputs, sep = envSep))
    bstinputs <- Sys.getenv("BSTINPUTS", unset = NA)
    if(is.na(bstinputs)) {
        on.exit(Sys.unsetenv("BSTINPUTS"), add = TRUE)
        bstinputs <- "."
    } else on.exit(Sys.setenv(BSTINPUTS = bstinputs), add = TRUE)
    Sys.setenv(BSTINPUTS = paste(bstinputs, texinputs, sep = envSep))

    if(nzchar(texi2dvi) && .Platform$OS.type != "windows") {
        opt_pdf <- if(pdf) "--pdf" else ""
        opt_quiet <- if(quiet) "--quiet" else ""
        opt_extra <- ""
        out <- .shell_with_capture(paste(shQuote(texi2dvi), "--help"))
        if(length(grep("--no-line-error", out$stdout)))
            opt_extra <- "--no-line-error"
        ## (Maybe change eventually: the current heuristics for finding
        ## error messages in log files should work for both regular and
        ## file line error indicators.)

        file.create(".timestamp")
        out <- .shell_with_capture(paste(shQuote(texi2dvi), opt_pdf,
                                         opt_quiet, opt_extra,
                                         shQuote(file)))

        ## We cannot necessarily rely on out$status, hence let us
        ## analyze the log files in any case.
        errors <- character()
        ## (La)TeX errors.
        log <- paste(file_path_sans_ext(file), "log", sep = ".")
        if(file_test("-f", log)) {
            lines <- .get_LaTeX_errors_from_log_file(log)
            if(length(lines))
                errors <- paste("LaTeX errors:",
                                paste(lines, collapse = "\n"),
                                sep = "\n")
        }
        ## BibTeX errors.
        log <- paste(file_path_sans_ext(file), "blg", sep = ".")
        if(file_test("-f", log)) {
            lines <- .get_BibTeX_errors_from_blg_file(log)
            if(length(lines))
                errors <- paste("BibTeX errors:",
                                paste(lines, collapse = "\n"),
                                sep = "\n")
        }

        msg <- ""
        if(out$status) {
            ## <NOTE>
            ## If we cannot rely on out$status, we could test for
            ##   if(out$status || length(errors))
            ## But shouldn't we be able to rely on out$status on Unix?
            ## </NOTE>
            msg <- gettextf("Running 'texi2dvi' on '%s' failed.", file)
            ## Error messages from GNU texi2dvi are rather terse, so
            ## only use them in case no additional diagnostics are
            ## available (e.g, makeindex errors).
            if(length(errors))
                msg <- paste(msg, errors, sep = "\n")
            else if(length(out$stderr))
                msg <- paste(msg, "Messages:",
                             paste(out$stderr, collapse = "\n"),
                             sep = "\n")
            if(!quiet)
                msg <- paste(msg, "Output:",
                             paste(out$stdout, collapse = "\n"),
                             sep = "\n")
        }

        ## Clean up as needed.
        if(clean) {
            out_file <- paste(file_path_sans_ext(file),
                              if(pdf) "pdf" else "dvi",
                              sep = ".")
            files <- list.files(all.files = TRUE) %w/o% c(".", "..",
                                                          out_file)
            file.remove(files[file_test("-nt", files, ".timestamp")])
        }
        file.remove(".timestamp")

        if(nzchar(msg))
            stop(msg, domain = NA)
        else if(!quiet)
            message(paste(paste(out$stderr, collapse = "\n"),
                          paste(out$stdout, collapse = "\n"),
                          sep = "\n"))
    } else if(nzchar(texi2dvi)) {       # Windows
        extra <- ""
        ext <- if(pdf) "pdf" else "dvi"
        pdf <- if(pdf) "--pdf" else ""
        file.create(".timestamp")
        quiet <- if(quiet) "--quiet" else ""

        ## look for MiKTeX (which this almost certainly is)
        ## and set the path to R's style files.
        ## -I works in MiKTeX >= 2.4, at least
        ver <- system(paste(shQuote(texi2dvi), "--version"), intern = TRUE)
        if(length(grep("MiKTeX", ver[1L]))) {
            paths <- paste ("-I", shQuote(texinputs))
            extra <- paste(extra, paste(paths, collapse = " "))
        }
        ## this only gives a failure in some cases, e.g. not for bibtex errors.
        system(paste(shQuote(texi2dvi), quiet, pdf,
                     shQuote(file), extra),
               intern=TRUE, ignore.stderr=TRUE)
        msg <- ""
        ## (La)TeX errors.
        log <- paste(file_path_sans_ext(file), "log", sep = ".")
        if(file_test("-f", log)) {
            lines <- .get_LaTeX_errors_from_log_file(log)
            if(length(lines))
                msg <- paste(msg, "LaTeX errors:",
                             paste(lines, collapse = "\n"),
                             sep = "\n")
        }
        ## BibTeX errors.
        log <- paste(file_path_sans_ext(file), "blg", sep = ".")
        if(file_test("-f", log)) {
            lines <- .get_BibTeX_errors_from_blg_file(log)
            if(length(lines))
                msg <- paste(msg, "BibTeX errors:",
                             paste(lines, collapse = "\n"),
                             sep = "\n")
        }

        if(nzchar(msg))
            msg <- paste(gettextf("running 'texi2dvi' on '%s' failed", file),
                         msg, "", sep = "\n")
        if(clean) {
            out_file <- paste(file_path_sans_ext(file), ext, sep = ".")
            files <- list.files(all.files = TRUE) %w/o% c(".", "..",
                                                          out_file)
            file.remove(files[file_test("-nt", files, ".timestamp")])
        }
        file.remove(".timestamp")

        if(nzchar(msg)) stop(msg, domain = NA)
    } else {
        ## Do not have texi2dvi
        ## Needed at least on Windows except for MiKTeX
        ## Note that this does not do anything about running quietly,
        ## nor cleaning, but is probably not used much anymore.

        texfile <- shQuote(file)
        base <- file_path_sans_ext(file)
        idxfile <- paste(base, ".idx", sep="")
        if(pdf) {
            latex <- Sys.getenv("PDFLATEX")
            if(!nzchar(latex)) latex <- "pdflatex"
        } else {
            latex <- Sys.getenv("LATEX")
            if(!nzchar(latex)) latex <- "latex"
        }
        bibtex <- Sys.getenv("BIBTEX")
        if(!nzchar(bibtex)) bibtex <- "bibtex"
        makeindex <- Sys.getenv("MAKEINDEX")
        if(!nzchar(makeindex)) makeindex <- "makeindex"
        if(system(paste(shQuote(latex), "-interaction=nonstopmode", texfile)))
            stop(gettextf("unable to run %s on '%s'", latex, file), domain = NA)
        nmiss <- length(grep("^LaTeX Warning:.*Citation.*undefined",
                             readLines(paste(base, ".log", sep = ""))))
        for(iter in 1L:10L) { ## safety check
            ## This might fail as the citations have been included in the Rnw
            if(nmiss) system(paste(shQuote(bibtex), shQuote(base)))
            nmiss_prev <- nmiss
            if(file.exists(idxfile)) {
                if(system(paste(shQuote(makeindex), shQuote(idxfile))))
                    stop(gettextf("unable to run %s on '%s'", makeindex, idxfile),
                         domain = NA)
            }
            if(system(paste(shQuote(latex), "-interaction=nonstopmode", texfile)))
                stop(gettextf("unable to run %s on '%s'", latex, file), domain = NA)
            Log <- readLines(paste(base, ".log", sep = ""))
            nmiss <- length(grep("^LaTeX Warning:.*Citation.*undefined", Log))
            if(nmiss == nmiss_prev &&
               !length(grep("Rerun to get", Log)) ) break
        }
    }
}

### * Internal utility variables.

### ** .BioC_version_associated_with_R_version

.BioC_version_associated_with_R_version <-
    numeric_version("2.5")
## (Could also use something programmatically mapping (R) 2.10.x to
## (BioC) 2.5, 2.9.x to 2.4, ..., 2.1.x to 1.6, but what if R 3.0.0
## comes out?)

### * Internal utility functions.

### ** %w/o%

## x without y, as in the examples of ?match.
`%w/o%` <-
function(x, y)
    x[!x %in% y]

### ** .OStype

.OStype <-
function()
{
    OS <- Sys.getenv("R_OSTYPE")
    if(nzchar(OS)) OS else .Platform$OS.type
}

### .R_top_srcdir

## Find the root directory of the source tree used for building this
## version of R (corresponding to Unix configure @top_srcdir@).
## Seems this is not recorded anywhere, but we can find our way ...

.R_top_srcdir_from_Rd <-
function() {
    filebase <-
        file_path_sans_ext(system.file("help", "tools.rdb",
                                       package = "tools"))
    path <- attr(fetchRdDB(filebase, "QC"), "Rdfile")
    ## We could use 5 dirname() calls, but perhaps more easily:
    substring(path, 1L, nchar(path) - 28L)
}

## Unfortunately,
##   .R_top_srcdir <- .R_top_srcdir_from_Rd()
## does not work because when tools is installed there are no Rd pages
## yet ...

### ** .eval_with_capture

.eval_with_capture <-
function(expr, type = NULL)
{
    ## Evaluate the given expression and return a list with elements
    ## 'value', 'output' and 'message' (with obvious meanings).

    ## <NOTE>
    ## The current implementation gives character() if capturing was not
    ## attempted of gave nothing.  If desired, one could modify the code
    ## to return NULL in the former case.
    ## </NOTE>

    if(is.null(type))
        capture_output <- capture_message <- TRUE
    else {
        type <- match.arg(type, c("output", "message"))
        capture_output <- type == "output"
        capture_message <- !capture_output
    }

    outcon <- file(open = "w+", encoding = "UTF-8")
    msgcon <- file(open = "w+", encoding = "UTF-8")
    if(capture_output) {
        sink(outcon, type = "output")
        on.exit(sink(type = "output"))
    }
    if(capture_message) {
        sink(msgcon, type = "message")
        on.exit(sink(type = "message"), add = capture_output)
    }
    on.exit({ close(outcon) ; close(msgcon) }, add = TRUE)

    value <- eval(expr)
    list(value = value,
         output = readLines(outcon, encoding = "UTF-8", warn = FALSE),
         message = readLines(msgcon, encoding = "UTF-8", warn = FALSE))
}


### ** .file_append_ensuring_LFs

.file_append_ensuring_LFs <-
function(file1, file2)
{
    ## Use a fast version of file.append() that ensures LF between
    ## files.
    .Internal(codeFiles.append(file1, file2))
}

### ** .find_owner_env

.find_owner_env <-
function(v, env, last = NA, default = NA) {
    while(!identical(env, last))
        if(exists(v, envir = env, inherits = FALSE))
            return(env)
        else
            env <- parent.env(env)
    default
}

### ** .get_BibTeX_errors_from_blg_file

.get_BibTeX_errors_from_blg_file <-
function(con)
{
    ## Get BibTeX error info, using non-header lines until the first
    ## warning or summary, hoping for the best ...
    lines <- readLines(con, warn = FALSE)
    if(any(ind <- is.na(nchar(lines, allowNA = TRUE))))
        lines[ind] <- iconv(lines[ind], "", "", sub = "byte")

    ## How can we find out for sure that there were errors?  Try
    ## guessing ... and peeking at tex-buf.el from AUCTeX.
    really_has_errors <-
        (length(grep("^---", lines)) ||
         regexpr("There (was|were) ([0123456789]+) error messages?",
                 lines[length(lines)]) > -1L)
    ## (Note that warnings are ignored for now.)
    ## MiKTeX does not give usage, so '(There were n error messages)' is
    ## last.
    pos <- grep("^(Warning|You|\\(There)", lines)
    if(!really_has_errors || !length(pos) ) return(character())
    ind <- seq.int(from = 3L, length.out = pos[1L] - 3L)
    lines[ind]
}

### ** .get_LaTeX_errors_from_log_file

.get_LaTeX_errors_from_log_file <-
function(con, n = 4L)
{
    ## Get (La)TeX lines with error plus n (default 4) lines of trailing
    ## context.
    lines <- readLines(con, warn = FALSE)
    if(any(ind <- is.na(nchar(lines, allowNA = TRUE))))
        lines[ind] <- iconv(lines[ind], "", "", sub = "byte")

    ## Try matching both the regular error indicator ('!') as well as
    ## the file line error indicator ('file:line:').
    pos <- grep("^(!|.*:[0123456789]+:)", lines)
    if(!length(pos)) return(character())
    ## Error chunk extends to at most the next error line.
    mapply(function(from, to) paste(lines[from : to], collapse = "\n"),
           pos, pmin(pos + n, c(pos[-1L], length(lines))))
}

### ** .get_contains_from_package_db

.get_contains_from_package_db <-
function(db)
{
    if("Contains" %in% names(db))
        unlist(strsplit(db["Contains"], "[[:space:]]+"))
    else
        character()
}

### ** .get_internal_S3_generics

.get_internal_S3_generics <-
function(primitive = TRUE) # primitive means 'include primitives'
{
    out <-
        ## Get the names of R internal S3 generics (via DispatchOrEval(),
        ## cf. zMethods.Rd).
        c("[", "[[", "$", "[<-", "[[<-", "$<-",
          "as.vector", "unlist",
          .get_S3_primitive_generics()
          ## ^^^^^^^ now contains the members of the group generics from
          ## groupGeneric.Rd.
          )
    if(!primitive)
        out <- out[!sapply(out, .is_primitive_in_base)]
    out
}

### ** .get_namespace_package_depends

.get_namespace_package_depends <-
function(dir)
{
    nsInfo <- .check_namespace(dir)
    depends <- c(sapply(nsInfo$imports, "[[", 1L),
                 sapply(nsInfo$importClasses, "[[", 1L),
                 sapply(nsInfo$importMethods, "[[", 1L))
    unique(sort(as.character(depends)))
}

### ** .get_namespace_S3_methods_db

.get_namespace_S3_methods_db <-
function(nsInfo)
{
    ## Get the registered S3 methods for an 'nsInfo' object returned by
    ## parseNamespaceFile(), as a 3-column character matrix with the
    ## names of the generic, class and method (as a function).
    S3_methods_list <- nsInfo$S3methods
    if(!length(S3_methods_list)) return(matrix(character(), ncol = 3L))
    idx <- is.na(S3_methods_list[, 3L])
    S3_methods_list[idx, 3L] <-
        paste(S3_methods_list[idx, 1L],
              S3_methods_list[idx, 2L],
              sep = ".")
    S3_methods_list
}

### ** .get_package_metadata

.get_package_metadata <-
function(dir, installed = FALSE)
{
    ## Get the package DESCRIPTION metadata for a package with root
    ## directory 'dir'.  If an unpacked source (uninstalled) package,
    ## base packages (have only a DESCRIPTION.in file with priority
    ## "base") and bundle packages (have a DESCRIPTION.in file and need
    ## additional metadata from the the bundle DESCRIPTION file) need
    ## special attention.
    dir <- file_path_as_absolute(dir)
    dfile <- file.path(dir, "DESCRIPTION")
    if(file_test("-f", dfile)) return(.read_description(dfile))
    if(installed) stop("File 'DESCRIPTION' is missing.")
    dfile <- file.path(dir, "DESCRIPTION.in")
    if(file_test("-f", dfile))
        meta <- .read_description(dfile)
    else
        stop("Files 'DESCRIPTION' and 'DESCRIPTION.in' are missing.")
    if(identical(as.character(meta["Priority"]), "base")) return(meta)
    ## Otherwise, this must be a bundle package.
    bdfile <- file.path(dirname(dir), "DESCRIPTION")
    if(file_test("-f", bdfile)) {
        file <- tempfile()
        on.exit(unlink(file))
        writeLines(c(readLines(bdfile), readLines(dfile)), file)
        .read_description(file)
        ## Using an anonymous tempfile (con <- file()) would work too
        ## for accumulating, e.g.,
        ##   con <- file(open = "w+")
        ##   on.exit(close(con))
        ##   writeLines(c(readLines(bdfile), readLines(dfile)), con)
        ## but .read_description() insists on an existing file (maybe
        ## this should be changed?).
    }
    else
        stop("Bundle 'DESCRIPTION' is missing.")
}

### ** .get_requires_from_package_db

.get_requires_from_package_db <-
function(db,
         category = c("Depends", "Imports", "LinkingTo", "Suggests", "Enhances"))
{
    category <- match.arg(category)
    if(category %in% names(db)) {
        requires <- unlist(strsplit(db[category], ","))
        requires <-
            sub("^[[:space:]]*([[:alnum:].]+).*$", "\\1", requires)
        if(category == "Depends")
            requires <- requires[requires != "R"]
    }
    else
        requires <- character()
    requires
}

### ** .get_requires_with_version_from_package_db

.get_requires_with_version_from_package_db <-
function(db,
         category = c("Depends", "Imports", "LinkingTo", "Suggests", "Enhances"))
{
    category <- match.arg(category)
    if(category %in% names(db)) {
        res <- .split_dependencies(db[category])
        if(category == "Depends") res[names(res) != "R"] else res
    } else list()
}

### ** .get_S3_generics_as_seen_from_package

.get_S3_generics_as_seen_from_package <-
function(dir, installed = TRUE, primitive = FALSE)
{
    ## Get the S3 generics "as seen from a package" rooted at
    ## @code{dir}.  Tricky ...
    if(basename(dir) == "base")
        env_list <- list()
    else {
        ## Always look for generics in the whole of the former base.
        ## (Not right, but we do not perform run time analyses when
        ## working off package sources.)  Maybe change this eventually,
        ## but we still cannot rely on packages to fully declare their
        ## dependencies on base packages.
        env_list <-
            list(baseenv(),
                 as.environment("package:graphics"),
                 as.environment("package:stats"),
                 as.environment("package:utils"))
        if(installed) {
            ## Also use the loaded namespaces and attached packages
            ## listed in the DESCRIPTION Depends and Imports fields.
            ## Not sure if this is the best approach: we could also try
            ## to determine which namespaces/packages were made
            ## available by loading the package (which should work at
            ## least when run from R CMD check), or we could simply
            ## attach every package listed as a dependency ... or
            ## perhaps do both.
            db <- .read_description(file.path(dir, "DESCRIPTION"))
            depends <- .get_requires_from_package_db(db, "Depends")
            imports <- .get_requires_from_package_db(db, "Imports")
            reqs <- intersect(c(depends, imports), loadedNamespaces())
            if(length(reqs))
                env_list <- c(env_list, lapply(reqs, getNamespace))
            ## note .packages give versioned names.
            reqs <- intersect(depends %w/o% loadedNamespaces(),
                              .packages())
            if(length(reqs))
                env_list <- c(env_list, lapply(reqs, .package_env))
            env_list <- unique(env_list)
        }
    }
    unique(c(.get_internal_S3_generics(primitive),
             unlist(lapply(env_list,
                           function(env) {
                               nms <- objects(envir = env,
                                              all.names = TRUE)
                               if(".no_S3_generics" %in% nms)
                                   character()
                               else Filter(function(f)
                                           .is_S3_generic(f, envir = env),
                                           nms)
                           }))))
}

### ** .get_S3_group_generics

.get_S3_group_generics <-
function()
    c("Ops", "Math", "Summary", "Complex")

### ** .get_S3_primitive_generics

.get_S3_primitive_generics <-
function(include_group_generics = TRUE)
{
    if(include_group_generics)
        c(base::.S3PrimitiveGenerics,
          "abs", "sign", "sqrt", "floor", "ceiling", "trunc", "round",
          "signif", "exp", "log", "expm1", "log1p",
          "cos", "sin", "tan", "acos", "asin", "atan",
          "cosh", "sinh", "tanh", "acosh", "asinh", "atanh",
          "lgamma", "gamma", "digamma", "trigamma",
          "cumsum", "cumprod", "cummax", "cummin",
          "+", "-", "*", "/", "^", "%%", "%/%", "&", "|", "!", "==",
          "!=", "<", "<=", ">=", ">",
          "all", "any", "sum", "prod", "max", "min", "range",
          "Arg", "Conj", "Im", "Mod", "Re")
    else
        base::.S3PrimitiveGenerics
}

### ** .get_standard_Rd_keywords

.get_standard_Rd_keywords <-
function()
{
    lines <- readLines(file.path(R.home("doc"), "KEYWORDS.db"))
    lines <- grep("^.*\\|([^:]*):.*", lines, value = TRUE)
    lines <- sub( "^.*\\|([^:]*):.*", "\\1", lines)
    lines
}

### ** .get_standard_package_names

## we cannot assume that file.path(R.home("share"), "make", "vars.mk")
## is installed, as it is not on Windows
.get_standard_package_names <-
local({
    lines <- readLines(file.path(R.home("share"), "make", "vars.mk"))
    lines <- grep("^R_PKGS_[[:upper:]]+ *=", lines, value = TRUE)
    out <- strsplit(sub("^R_PKGS_[[:upper:]]+ *= *", "", lines), " +")
    names(out) <-
        tolower(sub("^R_PKGS_([[:upper:]]+) *=.*", "\\1", lines))
    eval(substitute(function() {out}, list(out=out)), envir=NULL)
})

### ** .get_standard_repository_URLs

.get_standard_repository_URLs <-
function() {
    repos <- Sys.getenv("_R_CHECK_XREFS_REPOSITORIES_", "")
    repos <- if(nzchar(repos)) {
        .expand_BioC_repository_URLs(strsplit(repos, " +")[[1L]])
    } else {
        p <- file.path(Sys.getenv("HOME"), ".R", "repositories")
        if(file_test("-f", p)) {
            a <- .read_repositories(p)
            a[c("CRAN", "Omegahat", "BioCsoft", "BioCann", "BioCexp"),
              "URL"]
        } else {
            a <- .read_repositories(file.path(R.home("etc"),
                                              "repositories"))
            c("http://cran.r-project.org", a[3:6, "URL"])
        }
    }
    repos
}

### ** .get_standard_repository_db_fields

.get_standard_repository_db_fields <-
function()
    c("Package", "Version", "Priority",
      "Bundle", "Contains",
      "Depends", "Imports", "LinkingTo", "Suggests", "Enhances",
      "OS_type", "License")

### ** .is_ASCII

.is_ASCII <-
function(x)
{
    ## Determine whether the strings in a character vector are ASCII or
    ## not.
    as.logical(sapply(as.character(x),
                      function(txt)
                      all(charToRaw(txt) <= as.raw(127))))
}

### ** .is_ISO_8859

.is_ISO_8859 <-
function(x)
{
    ## Determine whether the strings in a character vector could be in
    ## some ISO 8859 character set or not.
    raw_ub <- charToRaw("\x7f")
    raw_lb <- charToRaw("\xa0")
    as.logical(sapply(as.character(x),
                      function(txt) {
                          raw <- charToRaw(txt)
                          all(raw <= raw_ub | raw >= raw_lb)
                      }))
}

### ** .is_primitive_in_base

.is_primitive_in_base <-
function(fname)
{
    ## Determine whether object named 'fname' found in the base
    ## environment is a primitive function.
    is.primitive(get(fname, envir = baseenv(), inherits = FALSE))
}

### ** .is_S3_generic

.is_S3_generic <-
function(fname, envir, mustMatch = TRUE)
{
    ## Determine whether object named 'fname' found in environment
    ## 'envir' is (to be considered) an S3 generic function.  Note,
    ## found *in* not found *from*, so envir does not have a default.
    ##
    ## If it is, does it despatch methods of fname?  We need that to
    ## look for possible methods as functions named fname.* ....
    ##
    ## Provided by LT with the following comments:
    ##
    ## This is tricky.  Figuring out what could possibly dispatch
    ## successfully some of the time is pretty much impossible given R's
    ## semantics.  Something containing a literal call to UseMethod is
    ## too broad in the sense that a UseMethod call in a local function
    ## doesn't produce a dispatch on the outer function ...
    ##
    ## If we use something like: a generic has to be
    ##      function(e) <UME>  # UME = UseMethod Expression
    ## with
    ##	    <UME> = UseMethod(...) |
    ##             if (...) <UME> [else ...] |
    ##             if (...) ... else <UME>
    ##             { ... <UME> ... }
    ## then a recognizer for UME might be as follows.

    f <- get(fname, envir = envir, inherits = FALSE)
    if(!is.function(f)) return(FALSE)
    isUMEbrace <- function(e) {
        for (ee in as.list(e[-1L])) if (nzchar(res <- isUME(ee))) return(res)
        ""
    }
    isUMEif <- function(e) {
        if (length(e) == 3L) isUME(e[[3L]])
        else {
            if (nzchar(res <- isUME(e[[3L]]))) res
            else if (nzchar(res <- isUME(e[[4L]]))) res
            else ""
        }

    }
    isUME <- function(e) {
        if (is.call(e) && (is.name(e[[1L]]) || is.character(e[[1L]]))) {
            switch(as.character(e[[1L]]),
                   UseMethod = as.character(e[[2L]]),
                   "{" = isUMEbrace(e),
                   "if" = isUMEif(e),
                   "")
        } else ""
    }
    res <- isUME(body(f))
    if(mustMatch) res == fname else nzchar(res)
}

### ** .load_package_quietly

.load_package_quietly <-
function(package, lib.loc)
{
    ## Load (reload if already loaded) @code{package} from
    ## @code{lib.loc}, capturing all output and messages.
    ## Don't do anything for base.
    ## Earlier versions did not attempt reloading methods as this used
    ## to cause trouble, but this now (2009-03-19) seems ok.
    ## Otoh, it seems that unloading tcltk is a bad idea ...
    ## Also, do not unload ourselves (but shouldn't we be "in use"?).
    ##
    ## All QC functions use this for loading packages because R CMD
    ## check interprets all output as indicating a problem.
    if(package != "base")
        .try_quietly({
            pos <- match(paste("package", package, sep = ":"), search())
            if(!is.na(pos)) {
                detach(pos = pos,
                       unload = ! package %in% c("tcltk", "tools"))
            }
            library(package, lib.loc = lib.loc, character.only = TRUE,
                    verbose = FALSE)
        })
}

### ** .make_file_exts

.make_file_exts <-
function(type = c("code", "data", "demo", "docs", "vignette"))
{
    ## Return a character vector with the possible/recognized file
    ## extensions for a given file type.
    switch(type,
           code = c("R", "r", "S", "s", "q"),
           ## Keep in sync with the order given in base's data.Rd.
           data = c("R", "r",
                    "RData", "rdata", "rda",
                    "tab", "txt", "TXT",
                    "tab.gz", "txt.gz",
                    "tab.bz2", "txt.bz2",
                    "tab.xz", "txt.xz",
                    "csv", "CSV",
                    "csv.gz", "csv,bz2", "csv.xz"),
           demo = c("R", "r"),
           docs = c("Rd", "rd", "Rd.gz", "rd.gz"),
           vignette = c(outer(c("R", "r", "S", "s"), c("nw", "tex"),
                              paste, sep = "")))
}

### ** .make_S3_group_generic_env

.make_S3_group_generic_env <-
function(parent = parent.frame())
{
    ## Create an environment with pseudo-definitions for the S3 group
    ## methods.
    env <- new.env(parent = parent)
    assign("Math", function(x, ...) UseMethod("Math"),
           envir = env)
    assign("Ops", function(e1, e2) UseMethod("Ops"),
           envir = env)
    assign("Summary", function(..., na.rm = FALSE) UseMethod("Summary"),
           envir = env)
    assign("Complex", function(z) UseMethod("Complex"),
           envir = env)
    env
}

### ** .make_S3_primitive_generic_env

.make_S3_primitive_generic_env <-
function(parent = parent.frame(), fixup = FALSE)
{
    ## Create an environment with pseudo-definitions for the S3 primitive
    ## generics
    env <- new.env(parent = parent)
    for(f in ls(base::.GenericArgsEnv))
        assign(f, get(f, envir=base::.GenericArgsEnv), envir = env)
    if(fixup) {
        ## now fixup the operators
        for(f in c('+', '-', '*', '/', '^', '%%', '%/%', '&', '|',
                   '==', '!=', '<', '<=', '>=', '>')) {
            fx <- get(f, envir = env)
            formals(fx) <- alist(x=, y=)
            assign(f, fx, envir = env)
        }
    }
    env
}

### ** .make_S3_primitive_nongeneric_env

.make_S3_primitive_nongeneric_env <-
function(parent = parent.frame())
{
    ## Create an environment with pseudo-definitions
    ## for the S3 primitive non-generics
    env <- new.env(parent = parent)
    for(f in ls(base::.ArgsEnv))
        assign(f, get(f, envir=base::.ArgsEnv), envir = env)
    env
}

### ** .make_S3_methods_stop_list

.make_S3_methods_stop_list <-
function(package)
{
    ## Return a character vector with the names of the functions in
    ## @code{package} which 'look' like S3 methods, but are not.
    ## Using package=NULL returns all known examples

    ## round.POSIXt is a method for S3 and S4 group generics with
    ## deliberately different arg names.
    stopList <-
        list(base = c("all.equal", "all.names", "all.vars",
             "format.char", "format.info", "format.pval",
             "kappa.tri",
             "max.col",
             "print.atomic", "print.coefmat",
             "qr.Q", "qr.R", "qr.X", "qr.coef", "qr.fitted", "qr.qty",
             "qr.qy", "qr.resid", "qr.solve",
             "rep.int", "round.POSIXt",
             "seq.int", "sort.int", "sort.list"),
             BSDA = "sign.test",
             Hmisc = c("abs.error.pred", "t.test.cluster"),
             HyperbolicDist = "log.hist",
             MASS = c("frequency.polygon",
             "gamma.dispersion", "gamma.shape",
             "hist.FD", "hist.scott"),
             ## FIXME: since these are already listed with 'base',
             ##        they should not need to be repeated here:
             Matrix = c("qr.Q", "qr.R", "qr.coef", "qr.fitted", "qr.qty", "qr.qy", "qr.resid"),
             SMPracticals = "exp.gibbs",
             XML = "text.SAX",
             ape = "sort.index",
	     assist = "chol.new",
             boot = "exp.tilt",
             car = "scatterplot.matrix",
	     calibrator = "t.fun",
             ctv = "update.views",
             equivalence = "sign.boot",
             fields = c("qr.q2ty", "qr.yq2"),
             grDevices = "boxplot.stats",
             graphics = c("close.screen",
             "plot.design", "plot.new", "plot.window", "plot.xy",
             "split.screen"),
             hier.part = "all.regs",
             lasso2 = "qr.rtr.inv",
             mratios = c("t.test.ratio.default", "t.test.ratio.formula"),
             quadprog = c("solve.QP", "solve.QP.compact"),
             reposTools = "update.packages2",
             sac = "cumsum.test",
             sm = "print.graph",
             stats = c("anova.lmlist", "fitted.values", "lag.plot",
             "influence.measures", "t.test"),
             supclust = c("sign.change", "sign.flip"),
	     tensorA = "chol.tensor",
             utils = c("close.socket", "flush.console", "update.packages")
             )
    if(is.null(package)) return(unlist(stopList))
    thisPkg <- stopList[[package, exact = TRUE]] # 'st' matched 'stats'
    if(!length(thisPkg)) character() else thisPkg
}

### ** .package_apply

.package_apply <-
function(packages = NULL, FUN, ...)
{
    ## Apply FUN and extra '...' args to all given packages.
    ## The default corresponds to all installed packages with high
    ## priority.
    if(is.null(packages))
        packages <-
            unique(utils::installed.packages(priority = "high")[ , 1L])
    out <- lapply(packages, function(p)
                  tryCatch(FUN(p, ...),
                           error = function(e)
                           noquote(paste("Error:",
                                         conditionMessage(e)))))
    ## (Just don't throw the error ...)
    names(out) <- packages
    out
}

### ** .read_Rd_lines_quietly

.read_Rd_lines_quietly <-
function(con)
{
    ## Read lines from a connection to an Rd file, trying to suppress
    ## "incomplete final line found by readLines" warnings.
    if(is.character(con)) {
        con <- if(length(grep("\\.gz$", con))) gzfile(con, "r") else file(con, "r")
        on.exit(close(con))
    }
    .try_quietly(readLines(con, warn=FALSE))
}

### ** .read_collate_field

.read_collate_field <-
function(txt)
{
    ## Read Collate specifications in DESCRIPTION files.
    ## These consist of file paths relative to the R code directory,
    ## separated by white space, possibly quoted.  Note that we could
    ## have newlines in DCF entries but do not allow them in file names,
    ## hence we gsub() them out.
    con <- textConnection(gsub("\n", " ", txt))
    on.exit(close(con))
    scan(con, what = character(), strip.white = TRUE, quiet = TRUE)
}

### ** .read_description

.read_description <-
function(dfile)
{
    ## Try reading in package metadata from a DESCRIPTION file.
    ## (Never clear whether this should work on the path of the file
    ## itself, or on that of the directory containing it.)
    ## <NOTE>
    ## As we do not have character "frames", we return a named character
    ## vector.
    ## </NOTE>
    if(!file_test("-f", dfile))
        stop(gettextf("file '%s' does not exist", dfile), domain = NA)
    out <- tryCatch(read.dcf(dfile)[1L, ],
                    error = function(e)
                    stop(gettextf("file '%s' is not in valid DCF format",
                                  dfile),
                         domain = NA, call. = FALSE))
    if(!is.na(encoding <- out["Encoding"])) {
        ## could convert everything to UTF-8
        if (encoding %in% c("latin1", "UTF-8"))
            Encoding(out) <- encoding
        else out <- iconv(out, encoding, "", sub = "byte")
    }
    out
}

### ** .read_repositories

.read_repositories <-
function(file)
{
    db <- utils::read.delim(file, header = TRUE, comment.char = "#",
                            colClasses =
                            c(rep.int("character", 3L),
                              rep.int("logical", 4L)))
    db[, "URL"] <- .expand_BioC_repository_URLs(db[, "URL"])
    db
}

.expand_BioC_repository_URLs <-
function(x) {
    x <- sub("%bm",
             as.character(getOption("BioC_mirror",
                                    "http://www.bioconductor.org")),
             x, fixed = TRUE)
    sub("%v",
        as.character(.BioC_version_associated_with_R_version),
        x, fixed = TRUE)
}

### ** .shell_with_capture

.shell_with_capture <-
function(command, input = NULL)
{
    ## Invoke a system command using a shell and capture its status,
    ## stdout and stderr into separate components.

    ## Should try some sanity checking that there is no redirection in
    ## command thus far ...
    outfile <- tempfile("xshell")
    errfile <- tempfile("xshell")
    on.exit(unlink(c(outfile, errfile)))
    status <- if(.Platform$OS.type == "windows")
        shell(sprintf("%s > %s 2> %s", command, outfile, errfile),
              input = input, shell = "cmd.exe")
    else system(sprintf("%s > %s 2> %s", command, outfile, errfile),
                input = input)
    list(status = status,
         stdout = readLines(outfile, warn = FALSE),
         stderr = readLines(errfile, warn = FALSE))
}

### ** .source_assignments

.source_assignments <-
function(file, envir, enc = NA)
{
    ## Read and parse expressions from @code{file}, and then
    ## successively evaluate the top-level assignments in @code{envir}.
    ## Apart from only dealing with assignments, basically does the same
    ## as @code{sys.source(file, envir, keep.source = FALSE)}.
    oop <- options(keep.source = FALSE)
    on.exit(options(oop))
    assignmentSymbolLM <- as.symbol("<-")
    assignmentSymbolEq <- as.symbol("=")
    if(!is.na(enc) &&
       !(Sys.getlocale("LC_CTYPE") %in% c("C", "POSIX"))) {
        con <- file(file, encoding = enc)
        on.exit(close(con))
    } else con <- file
    exprs <- parse(n = -1L, file = con)
    if(!length(exprs))
        return(invisible())
    for(e in exprs) {
        if(e[[1L]] == assignmentSymbolLM || e[[1L]] == assignmentSymbolEq)
            eval(e, envir)
    }
    invisible()
}

### .source_assignments_in_code_dir

.source_assignments_in_code_dir <-
function(dir, envir, meta = character())
{
    ## Combine all code files in @code{dir}, read and parse expressions,
    ## and successively evaluate the top-level assignments in @code{envir}.
    con <- tempfile("Rcode")
    on.exit(unlink(con))
    if(!file.create(con))
        stop("unable to create ", con)
    ## If the (DESCRIPTION) metadata contain a Collate specification,
    ## use this for determining the code files and their order.
    txt <- meta[c(paste("Collate", .OStype(), sep = "."), "Collate")]
    ind <- which(!is.na(txt))
    files <- if(any(ind))
        Filter(function(x) file_test("-f", x),
               file.path(dir, .read_collate_field(txt[ind[1L]])))
    else
        list_files_with_type(dir, "code")
    if(!all(.file_append_ensuring_LFs(con, files)))
        stop("unable to write code files")
    tryCatch(.source_assignments(con, envir, enc = meta["Encoding"]),
             error =
             function(e)
             stop("cannot source package code\n",
                  conditionMessage(e),
                  call. = FALSE))
}

### * .split_dependencies

.split_dependencies <-
function(x)
{
    ## given one or more Depends: or Suggests: fields from DESCRIPTION
    ## return a named list of list (name, [op, version])
    if(!length(x)) return(list())
    x <- unlist(strsplit(x, ","))
    ## some have had space before ,
    x <- sub('[[:space:]]+$', '', x)
    x <- unique(sub("^[[:space:]]*(.*)", "\\1" , x))
    names(x) <- sub("^([[:alnum:].]+).*$", "\\1" , x)
    lapply(x, .split_op_version)
}

### * .split_op_version

.split_op_version <-
function(x)
{
    ## given a single piece of dependency
    ## return a list of components (name, [op, version])
    ## NB this relies on trailing space having been removed
    pat <- "^([^\\([:space:]]+)[[:space:]]*\\(([^\\)]+)\\).*"
    x1 <- sub(pat, "\\1", x)
    x2 <- sub(pat, "\\2", x)
    if(x2 != x1) {
        pat <- "[[:space:]]*([[<>=!]+)[[:space:]]+(.*)"
        list(name = x1, op = sub(pat, "\\1", x2),
             version = package_version(sub(pat, "\\2", x2)))
    } else list(name = x1)
}

### ** .strip_whitespace

.strip_whitespace <-
function(x)
{
    ## Strip leading and trailing whitespace.
    x <- sub("^[[:space:]]+", "", x)
    x <- sub("[[:space:]]+$", "", x)
    x
}

### ** .try_quietly

.try_quietly <-
function(expr)
{
    ## Try to run an expression, suppressing all 'output'.  In case of
    ## failure, stop with the error message and a "traceback" ...

    oop <- options(warn = 1)
    on.exit(options(oop))
    outConn <- file(open = "w+")         # anonymous tempfile
    sink(outConn, type = "output")
    sink(outConn, type = "message")
    yy <- tryCatch(withRestarts(withCallingHandlers(expr, error = {
        function(e) invokeRestart("grmbl", e, sys.calls())
    }),
                                grmbl = function(e, calls) {
                                    n <- length(sys.calls())
                                    ## Chop things off as needed ...
                                    calls <- calls[-seq.int(length.out = n - 1L)]
                                    calls <- rev(calls)[-c(1L, 2L)]
                                    tb <- lapply(calls, deparse)
                                    stop(conditionMessage(e),
                                         "\nCall sequence:\n",
                                         paste(.eval_with_capture(traceback(tb))$output,
                                               collapse = "\n"),
                                         call. = FALSE)
                                }),
                   error = identity,
                   finally = {
                       sink(type = "message")
                       sink(type = "output")
                       close(outConn)
                   })
    if(inherits(yy, "error"))
        stop(yy)
    yy
}

### ** .wrong_args

.wrong_args <-
function(args, msg)
{
    len <- length(args)
    if(!len)
        character()
    else if(len == 1L)
        paste("argument", sQuote(args), msg)
    else
        paste("arguments",
              paste(c(rep.int("", len - 1L), "and "),
                    sQuote(args),
                    c(rep.int(", ", len - 1L), ""),
                    sep = "", collapse = ""),
              msg)
}


### Local variables: ***
### mode: outline-minor ***
### outline-regexp: "### [*]+" ***
### End: ***
